home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / fast-init.lisp < prev    next >
Lisp/Scheme  |  1992-12-21  |  34KB  |  889 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;;
  28. ;;; This file defines the optimized make-instance functions.
  29. ;;; 
  30.  
  31. (in-package :pcl)
  32.  
  33. (defvar *compile-make-instance-functions-p* nil)
  34.  
  35. (defun update-make-instance-function-table (&optional (class *the-class-t*))
  36.   (when (symbolp class) (setq class (find-class class)))
  37.     (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
  38.     (when (memq *the-class-slot-object* (class-precedence-list class))
  39.       (map-all-classes #'reset-class-initialize-info class)))
  40.  
  41. (defun constant-symbol-p (form)
  42.   (and (constantp form) 
  43.        (let ((object (eval form)))
  44.      (and (symbolp object)
  45.           (symbol-package object)))))
  46.  
  47. (defvar *make-instance-function-keys* nil)
  48.  
  49. (defun expand-make-instance-form (form)
  50.   (let ((class (cadr form)) (initargs (cddr form))
  51.     (keys nil)(allow-other-keys-p nil) key value)
  52.     (when (and (constant-symbol-p class)
  53.            (let ((initargs-tail initargs))
  54.          (loop (when (null initargs-tail) (return t))
  55.                (unless (constant-symbol-p (car initargs-tail))
  56.              (return nil))               
  57.                (setq key (eval (pop initargs-tail)))
  58.                (setq value (pop initargs-tail))
  59.                (when (eq ':allow-other-keys key)
  60.              (setq allow-other-keys-p value))
  61.                (push key keys))))
  62.       (let* ((class (eval class))
  63.          (keys (nreverse keys))
  64.          (key (list class keys allow-other-keys-p))
  65.          (sym (make-instance-function-symbol key)))
  66.     (push key *make-instance-function-keys*)
  67.     (when sym
  68.       `(,sym ',class (list ,@initargs)))))))
  69.  
  70. (defmacro expanding-make-instance-top-level (&rest forms &environment env)
  71.   (let* ((*make-instance-function-keys* nil)
  72.      (form (macroexpand `(expanding-make-instance ,@forms) env)))
  73.     `(progn
  74.        ,@(when *make-instance-function-keys*
  75.        `((get-make-instance-functions ',*make-instance-function-keys*)))
  76.        ,form)))
  77.       
  78. (defmacro expanding-make-instance (&rest forms &environment env)
  79.   `(progn
  80.      ,@(mapcar #'(lambda (form)
  81.            (walk-form form env 
  82.                   #'(lambda (subform context env)
  83.                   (declare (ignore env))
  84.                   (or (and (eq context ':eval)
  85.                        (consp subform)
  86.                        (eq (car subform) 'make-instance)
  87.                        (expand-make-instance-form subform))
  88.                       subform))))
  89.            forms)))
  90.  
  91. (defmacro defconstructor
  92.       (name class lambda-list &rest initialization-arguments)
  93.   `(expanding-make-instance-top-level
  94.     (defun ,name ,lambda-list
  95.       (make-instance ',class ,@initialization-arguments))))
  96.  
  97. (defun get-make-instance-functions (key-list)
  98.   (dolist (key key-list)
  99.     (let* ((cell (find-class-cell (car key)))
  100.        (make-instance-function-keys 
  101.         (find-class-cell-make-instance-function-keys cell))
  102.        (mif-key (cons (cadr key) (caddr key))))
  103.       (unless (find mif-key make-instance-function-keys 
  104.             :test #'equal)
  105.     (push mif-key (find-class-cell-make-instance-function-keys cell))
  106.     (let ((class (find-class-cell-class cell)))
  107.       (when (and class (not (forward-referenced-class-p class)))
  108.         (update-initialize-info-internal
  109.          (initialize-info class (car mif-key) nil (cdr mif-key))
  110.          'make-instance-function)))))))
  111.  
  112. (defun make-instance-function-symbol (key)
  113.   (let* ((class (car key))
  114.      (symbolp (symbolp class)))
  115.     (when (or symbolp (classp class))
  116.       (let* ((class-name (if (symbolp class) class (class-name class)))
  117.          (keys (cadr key))
  118.          (allow-other-keys-p (caddr key)))
  119.     (when (and (or symbolp 
  120.                (and (symbolp class-name)
  121.                 (eq class (find-class class-name nil))))
  122.            (symbol-package class-name))
  123.       (let ((*package* *the-pcl-package*)
  124.         (*print-length* nil) (*print-level* nil)
  125.         (*print-circle* nil) (*print-case* :upcase)
  126.         (*print-pretty* nil))
  127.         (intern (format nil "MAKE-INSTANCE ~S ~S ~S"
  128.                 class-name keys allow-other-keys-p))))))))
  129.  
  130. (defun make-instance-1 (class initargs)
  131.   (apply #'make-instance class initargs))
  132.  
  133. (defmacro define-cached-reader (type name trap)
  134.   (let ((reader-name (intern (format nil "~A-~A" type name)))
  135.     (cached-name (intern (format nil "~A-CACHED-~A" type name))))
  136.     `(defmacro ,reader-name (info)
  137.        `(let ((value (,',cached-name ,info)))
  138.       (if (eq value ':unknown)
  139.           (progn
  140.         (,',trap ,info ',',name)
  141.         (,',cached-name ,info))
  142.           value)))))
  143.  
  144. (eval-when (compile load eval)
  145. (defparameter initialize-info-cached-slots
  146.   '(valid-p                ; t or (:invalid key)
  147.     ri-valid-p
  148.     initargs-form-list
  149.     new-keys
  150.     default-initargs-function
  151.     shared-initialize-t-function
  152.     shared-initialize-nil-function
  153.     constants
  154.     combined-initialize-function ; allocate-instance + shared-initialize
  155.     make-instance-function ; nil means use gf
  156.     make-instance-function-symbol)))
  157.  
  158. (defmacro define-initialize-info ()
  159.   (let ((cached-slot-names 
  160.      (mapcar #'(lambda (name)
  161.              (intern (format nil "CACHED-~A" name)))
  162.          initialize-info-cached-slots))
  163.     (cached-names
  164.      (mapcar #'(lambda (name)
  165.              (intern (format nil "~A-CACHED-~A" 
  166.                      'initialize-info name)))
  167.          initialize-info-cached-slots)))
  168.     `(progn
  169.        (defstruct initialize-info 
  170.      key wrapper 
  171.      ,@(mapcar #'(lambda (name)
  172.                `(,name :unknown))
  173.            cached-slot-names))
  174.        (defmacro reset-initialize-info-internal (info)
  175.      `(progn 
  176.         ,@(mapcar #'(lambda (cname)
  177.               `(setf (,cname ,info) ':unknown))
  178.               ',cached-names)))
  179.        (defun initialize-info-bound-slots (info)
  180.      (let ((slots nil))
  181.        ,@(mapcar #'(lambda (name cached-name)
  182.              `(unless (eq ':unknown (,cached-name info))
  183.                 (push ',name slots)))
  184.              initialize-info-cached-slots cached-names)
  185.        slots))
  186.       ,@(mapcar #'(lambda (name)
  187.             `(define-cached-reader initialize-info ,name 
  188.               update-initialize-info-internal))
  189.             initialize-info-cached-slots))))
  190.  
  191. (define-initialize-info)
  192.  
  193. (defvar *initialize-info-cache-class* nil)
  194. (defvar *initialize-info-cache-initargs* nil)
  195. (defvar *initialize-info-cache-info* nil)
  196.  
  197. (defvar *revert-initialize-info-p* nil)
  198.  
  199. (defun reset-initialize-info (info)
  200.   (setf (initialize-info-wrapper info)
  201.     (class-wrapper (car (initialize-info-key info))))
  202.   (let ((slots-to-revert (if *revert-initialize-info-p*
  203.                  (initialize-info-bound-slots info)
  204.                  '(make-instance-function))))
  205.     (reset-initialize-info-internal info)
  206.     (dolist (slot slots-to-revert)
  207.       (update-initialize-info-internal info slot))
  208.     info))
  209.  
  210. (defun reset-class-initialize-info (class)
  211.   (reset-class-initialize-info-1 (class-initialize-info class)))
  212.  
  213. (defun reset-class-initialize-info-1 (cell)
  214.   (when (consp cell)
  215.     (when (car cell)
  216.       (reset-initialize-info (car cell)))
  217.     (let ((alist (cdr cell)))
  218.       (dolist (a alist)
  219.     (reset-class-initialize-info-1 (cdr a))))))
  220.  
  221. (defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
  222.   (let ((info nil))
  223.     (if (and (eq *initialize-info-cache-class* class)
  224.          (eq *initialize-info-cache-initargs* initargs))
  225.     (setq info *initialize-info-cache-info*)
  226.     (let ((initargs-tail initargs)
  227.           (cell (or (class-initialize-info class)
  228.             (setf (class-initialize-info class) (cons nil nil)))))
  229.       (loop (when (null initargs-tail) (return nil))
  230.         (let ((keyword (pop initargs-tail))
  231.               (alist-cell cell))
  232.           (when plist-p
  233.             (if (eq keyword :allow-other-keys)
  234.             (setq allow-other-keys-arg (pop initargs-tail))
  235.             (pop initargs-tail)))
  236.           (loop (let ((alist (cdr alist-cell)))
  237.               (when (null alist)
  238.                 (setq cell (cons nil nil))
  239.                 (setf (cdr alist-cell) (list (cons keyword cell)))
  240.                 (return nil))
  241.               (when (eql keyword (caar alist))
  242.                 (setq cell (cdar alist))
  243.                 (return nil))
  244.               (setq alist-cell alist)))))
  245.       (setq info (or (car cell)
  246.              (setf (car cell) (make-initialize-info))))))
  247.     (let ((wrapper (initialize-info-wrapper info)))
  248.       (unless (eq wrapper (class-wrapper class))
  249.     (unless wrapper
  250.       (let* ((initargs-tail initargs)
  251.          (klist-cell (list nil))
  252.          (klist-tail klist-cell))
  253.         (loop (when (null initargs-tail) (return nil))
  254.           (let ((key (pop initargs-tail)))
  255.             (setf (cdr klist-tail) (list key)))
  256.           (setf klist-tail (cdr klist-tail))
  257.           (when plist-p (pop initargs-tail)))
  258.         (setf (initialize-info-key info)
  259.           (list class (cdr klist-cell) allow-other-keys-arg))))
  260.     (reset-initialize-info info)))
  261.     (setq *initialize-info-cache-class* class)
  262.     (setq *initialize-info-cache-initargs* initargs)
  263.     (setq *initialize-info-cache-info* info)    
  264.     info))
  265.  
  266. (defun update-initialize-info-internal (info name)
  267.   (let* ((key (initialize-info-key info))
  268.      (class (car key))
  269.      (keys (cadr key))
  270.      (allow-other-keys-arg (caddr key)))
  271.     (ecase name
  272.       ((initargs-form-list new-keys)
  273.        (multiple-value-bind (initargs-form-list new-keys)
  274.        (make-default-initargs-form-list class keys)
  275.      (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
  276.      (setf (initialize-info-cached-new-keys info) new-keys)))
  277.       ((default-initargs-function)
  278.        (let ((initargs-form-list (initialize-info-initargs-form-list info)))
  279.      (setf (initialize-info-cached-default-initargs-function info)
  280.            (initialize-instance-simple-function 
  281.         'default-initargs-function info
  282.         class initargs-form-list))))
  283.       ((valid-p ri-valid-p)
  284.        (flet ((compute-valid-p (methods)
  285.         (or (not (null allow-other-keys-arg))
  286.             (multiple-value-bind (legal allow-other-keys)
  287.             (check-initargs-values class methods)
  288.               (or (not (null allow-other-keys))
  289.               (dolist (key keys t)
  290.                 (unless (member key legal)
  291.                   (return (cons :invalid key)))))))))
  292.      (let ((proto (class-prototype class)))
  293.        (setf (initialize-info-cached-valid-p info)
  294.          (compute-valid-p
  295.           (list (list* 'allocate-instance class nil)
  296.             (list* 'initialize-instance proto nil)
  297.             (list* 'shared-initialize proto t nil))))
  298.        (setf (initialize-info-cached-ri-valid-p info)
  299.          (compute-valid-p 
  300.           (list (list* 'reinitialize-instance proto nil)
  301.             (list* 'shared-initialize proto nil nil)))))))
  302.       ((shared-initialize-t-function)
  303.        (multiple-value-bind (initialize-form-list ignore)
  304.        (make-shared-initialize-form-list class keys t nil)
  305.      (declare (ignore ignore))
  306.      (setf (initialize-info-cached-shared-initialize-t-function info)
  307.            (initialize-instance-simple-function 
  308.         'shared-initialize-t-function info
  309.         class initialize-form-list))))
  310.       ((shared-initialize-nil-function)
  311.        (multiple-value-bind (initialize-form-list ignore)
  312.        (make-shared-initialize-form-list class keys nil nil)
  313.      (declare (ignore ignore))
  314.      (setf (initialize-info-cached-shared-initialize-nil-function info)
  315.            (initialize-instance-simple-function 
  316.         'shared-initialize-nil-function info 
  317.         class initialize-form-list))))
  318.       ((constants combined-initialize-function)
  319.        (let ((initargs-form-list (initialize-info-initargs-form-list info))
  320.          (new-keys (initialize-info-new-keys info)))
  321.      (multiple-value-bind (initialize-form-list constants)
  322.          (make-shared-initialize-form-list class new-keys t t)
  323.        (setf (initialize-info-cached-constants info) constants)
  324.        (setf (initialize-info-cached-combined-initialize-function info)
  325.          (initialize-instance-simple-function 
  326.           'combined-initialize-function info 
  327.           class (append initargs-form-list initialize-form-list))))))
  328.       ((make-instance-function-symbol)
  329.        (setf (initialize-info-cached-make-instance-function-symbol info)
  330.          (make-instance-function-symbol key)))
  331.       ((make-instance-function)
  332.        (let* ((function (get-make-instance-function key))
  333.           (symbol (initialize-info-make-instance-function-symbol info)))
  334.      (setf (initialize-info-cached-make-instance-function info) function)
  335.      (when symbol (setf (gdefinition symbol)
  336.                 (or function #'make-instance-1)))))))
  337.   info)
  338.  
  339. (defun get-make-instance-function (key)
  340.   (let* ((class (car key))
  341.      (keys (cadr key)))
  342.     (unless (eq *boot-state* 'complete) 
  343.       (return-from get-make-instance-function nil))
  344.     (when (symbolp class)
  345.       (setq class (find-class class)))
  346.     (when (classp class)
  347.       (unless (class-finalized-p class) (finalize-inheritance class)))
  348.     (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
  349.        (class-and-initargs (list* class initargs))
  350.        (make-instance (gdefinition 'make-instance))
  351.        (make-instance-methods
  352.         (compute-applicable-methods make-instance class-and-initargs))
  353.        (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
  354.        (class+initargs (list class initargs))
  355.        (default-initargs (gdefinition 'default-initargs))
  356.        (default-initargs-methods
  357.            (compute-applicable-methods default-initargs class+initargs))
  358.        (proto (and (classp class) (class-prototype class)))
  359.        (initialize-instance-methods
  360.         (when proto
  361.           (compute-applicable-methods (gdefinition 'initialize-instance)
  362.                       (list* proto initargs))))
  363.        (shared-initialize-methods
  364.         (when proto
  365.           (compute-applicable-methods (gdefinition 'shared-initialize)
  366.                       (list* proto t initargs)))))
  367.       (when (null make-instance-methods)
  368.     (return-from get-make-instance-function
  369.       #'(lambda (class initargs)
  370.           (apply #'no-applicable-method make-instance class initargs))))
  371.       (unless (and (null (cdr make-instance-methods))
  372.            (eq (car make-instance-methods) std-mi-meth)
  373.            (null (cdr default-initargs-methods))
  374.            (eq (car (method-specializers (car default-initargs-methods)))
  375.                *the-class-slot-class*)
  376.            (flet ((check-meth (meth)
  377.                 (let ((quals (method-qualifiers meth)))
  378.                   (if (null quals)
  379.                   (eq (car (method-specializers meth))
  380.                       *the-class-slot-object*)
  381.                   (and (null (cdr quals))
  382.                        (or (eq (car quals) ':before)
  383.                        (eq (car quals) ':after)))))))
  384.              (and (every #'check-meth initialize-instance-methods)
  385.               (every #'check-meth shared-initialize-methods))))
  386.     (return-from get-make-instance-function nil))
  387.       (get-make-instance-function-internal 
  388.        class key (default-initargs class initargs) 
  389.        initialize-instance-methods shared-initialize-methods))))
  390.  
  391. (defun get-make-instance-function-internal (class key initargs 
  392.                           initialize-instance-methods
  393.                           shared-initialize-methods)
  394.   (let* ((keys (cadr key))
  395.      (allow-other-keys-p (caddr key))
  396.      (allocate-instance-methods
  397.       (compute-applicable-methods (gdefinition 'allocate-instance)
  398.                       (list* class initargs))))
  399.     (unless allow-other-keys-p
  400.       (unless (check-initargs-1
  401.            class initargs
  402.            (append allocate-instance-methods
  403.                initialize-instance-methods
  404.                shared-initialize-methods)
  405.            t nil)
  406.     (return-from get-make-instance-function-internal nil)))
  407.     (if (or (cdr allocate-instance-methods)
  408.         (some #'complicated-instance-creation-method
  409.           initialize-instance-methods)
  410.         (some #'complicated-instance-creation-method
  411.           shared-initialize-methods))
  412.     (make-instance-function-complex
  413.      key class keys
  414.      initialize-instance-methods shared-initialize-methods)
  415.     (make-instance-function-simple
  416.      key class keys
  417.      initialize-instance-methods shared-initialize-methods))))
  418.  
  419. (defun complicated-instance-creation-method (m)
  420.   (let ((qual (method-qualifiers m)))
  421.     (if qual 
  422.     (not (and (null (cdr qual)) (eq (car qual) ':after)))
  423.     (let ((specl (car (method-specializers m))))
  424.       (or (not (classp specl))
  425.           (not (eq 'slot-object (class-name specl))))))))
  426.  
  427. (defun find-standard-ii-method (methods class-names)
  428.   (dolist (m methods)
  429.     (when (null (method-qualifiers m))
  430.       (let ((specl (car (method-specializers m))))
  431.     (when (and (classp specl)
  432.            (if (listp class-names)
  433.                (member (class-name specl) class-names)
  434.                (eq (class-name specl) class-names)))
  435.       (return m))))))
  436.  
  437. (defmacro call-initialize-function (initialize-function instance initargs)
  438.   `(let ((.function. ,initialize-function))
  439.      (if (and (consp .function.)
  440.           (eq (car .function.) 'call-initialize-instance-simple))
  441.      (initialize-instance-simple (cadr .function.) (caddr .function.)
  442.                      ,instance ,initargs)
  443.      (funcall (the function .function.) ,instance ,initargs))))
  444.  
  445. (defun make-instance-function-simple (key class keys
  446.                       initialize-instance-methods 
  447.                       shared-initialize-methods)
  448.   (multiple-value-bind (initialize-function constants)
  449.       (get-simple-initialization-function class keys (caddr key))
  450.     (let* ((wrapper (class-wrapper class))
  451.        (lwrapper (list wrapper))
  452.        (allocate-function 
  453.         (cond ((structure-class-p class)
  454.            #'allocate-structure-instance)
  455.           ((standard-class-p class)
  456.            #'allocate-standard-instance)
  457.           ((funcallable-standard-class-p class)
  458.            #'allocate-funcallable-instance)
  459.           (t 
  460.            (error "error in make-instance-function-simple"))))
  461.        (std-si-meth (find-standard-ii-method shared-initialize-methods
  462.                          'slot-object))
  463.        (shared-initfns
  464.         (nreverse (mapcar #'(lambda (method)
  465.                   (make-effective-method-function
  466.                    #'shared-initialize
  467.                    `(call-method ,method nil)
  468.                    nil lwrapper))
  469.                   (remove std-si-meth shared-initialize-methods))))
  470.        (std-ii-meth (find-standard-ii-method initialize-instance-methods
  471.                          'slot-object))
  472.        (initialize-initfns 
  473.         (nreverse (mapcar #'(lambda (method)
  474.                   (make-effective-method-function
  475.                    #'initialize-instance
  476.                    `(call-method ,method nil)
  477.                    nil lwrapper))
  478.                   (remove std-ii-meth
  479.                       initialize-instance-methods)))))
  480.       #'(lambda (class1 initargs)
  481.       (if (not (eq wrapper (class-wrapper class)))
  482.           (let* ((info (initialize-info class1 initargs))
  483.              (fn (initialize-info-make-instance-function info)))
  484.         (declare (type function fn))
  485.         (funcall fn class1 initargs))
  486.           (let* ((instance (funcall allocate-function wrapper constants))
  487.              (initargs (call-initialize-function initialize-function
  488.                              instance initargs)))
  489.         (dolist (fn shared-initfns)
  490.           (invoke-effective-method-function fn t instance t initargs))
  491.         (dolist (fn initialize-initfns)
  492.           (invoke-effective-method-function fn t instance initargs))
  493.         instance))))))
  494.  
  495. (defun make-instance-function-complex (key class keys
  496.                        initialize-instance-methods
  497.                        shared-initialize-methods)
  498.   (multiple-value-bind (initargs-function initialize-function)
  499.       (get-complex-initialization-functions class keys (caddr key))
  500.     (let* ((wrapper (class-wrapper class))
  501.        (shared-initialize
  502.         (get-secondary-dispatch-function
  503.          #'shared-initialize shared-initialize-methods
  504.          `((class-eq ,class) t t)
  505.          `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
  506.         ,#'(lambda (instance init-type &rest initargs)
  507.              (declare (ignore init-type))
  508.              #+copy-&rest-arg (setq initargs (copy-list initargs))
  509.              (call-initialize-function initialize-function 
  510.                            instance initargs)
  511.              instance)))
  512.          (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
  513.        (initialize-instance
  514.         (get-secondary-dispatch-function
  515.          #'initialize-instance initialize-instance-methods
  516.          `((class-eq ,class) t)
  517.          `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
  518.         ,#'(lambda (instance &rest initargs)
  519.              #+copy-&rest-arg (setq initargs (copy-list initargs))
  520.              (invoke-effective-method-function
  521.               shared-initialize t instance t initargs))))
  522.          (list wrapper *the-wrapper-of-t*))))
  523.       #'(lambda (class1 initargs)
  524.       (if (not (eq wrapper (class-wrapper class)))
  525.           (let* ((info (initialize-info class1 initargs))
  526.              (fn (initialize-info-make-instance-function info)))
  527.         (declare (type function fn))
  528.         (funcall fn class1 initargs))
  529.           (let* ((initargs (call-initialize-function initargs-function 
  530.                              nil initargs))
  531.              (instance (apply #'allocate-instance class initargs)))
  532.         (invoke-effective-method-function
  533.          initialize-instance t instance initargs)
  534.         instance))))))
  535.  
  536. (defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
  537.   (let ((info (initialize-info class keys nil allow-other-keys-arg)))
  538.     (values (initialize-info-combined-initialize-function info)
  539.         (initialize-info-constants info))))
  540.  
  541. (defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
  542.                            separate-p)
  543.   (let* ((info (initialize-info class keys nil allow-other-keys-arg))
  544.      (default-initargs-function (initialize-info-default-initargs-function info)))
  545.     (if separate-p
  546.     (values default-initargs-function
  547.         (initialize-info-shared-initialize-t-function info))
  548.     (values default-initargs-function
  549.         (initialize-info-shared-initialize-t-function
  550.          (initialize-info class (initialize-info-new-keys info)
  551.                   nil allow-other-keys-arg))))))
  552.  
  553. (defun add-forms (forms forms-list)
  554.   (when forms
  555.     (setq forms (copy-list forms))
  556.     (if (null (car forms-list))
  557.     (setf (car forms-list) forms)
  558.     (setf (cddr forms-list) forms))
  559.     (setf (cdr forms-list) (last forms)))
  560.   (car forms-list))
  561.  
  562. (defun make-default-initargs-form-list (class keys &optional (separate-p t))
  563.   (let ((initargs-form-list (cons nil nil))
  564.     (default-initargs (class-default-initargs class))
  565.     (nkeys keys))
  566.     (dolist (default default-initargs)
  567.       (let ((key (car default))
  568.         (function (cadr default)))
  569.     (unless (member key nkeys)
  570.       (add-forms `((funcall ,function) (push-initarg ,key))
  571.              initargs-form-list)
  572.       (push key nkeys))))
  573.     (when separate-p
  574.       (add-forms `((update-initialize-info-cache
  575.             ,class ,(initialize-info class nkeys nil)))
  576.          initargs-form-list))
  577.     (add-forms `((finish-pushing-initargs))
  578.            initargs-form-list)
  579.     (values (car initargs-form-list) nkeys)))
  580.  
  581. (defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
  582.   (let* ((initialize-form-list (cons nil nil))
  583.      (type (cond ((structure-class-p class)
  584.               'structure)
  585.              ((standard-class-p class)
  586.               'standard)
  587.              ((funcallable-standard-class-p class)
  588.               'funcallable)
  589.              (t (error "error in make-shared-initialize-form-list"))))
  590.      (wrapper (class-wrapper class))
  591.      (constants (when simple-p
  592.               (make-list (wrapper-no-of-instance-slots wrapper)
  593.                  ':initial-element *slot-unbound*)))
  594.      (slots (class-slots class))
  595.      (slot-names (mapcar #'slot-definition-name slots))
  596.      (slots-key (mapcar #'(lambda (slot)
  597.                 (let ((index most-positive-fixnum))
  598.                   (dolist (key (slot-definition-initargs slot))
  599.                     (let ((pos (position key keys)))
  600.                       (when pos (setq index (min index pos)))))
  601.                   (cons slot index)))
  602.                 slots))
  603.      (slots (stable-sort slots-key #'< :key #'cdr)))
  604.     (let ((n-popped 0))
  605.       (dolist (slot+index slots)
  606.     (let* ((slot (car slot+index))
  607.            (name (slot-definition-name slot))
  608.            (npop (1+ (- (cdr slot+index) n-popped))))
  609.       (unless (eql (cdr slot+index) most-positive-fixnum)
  610.         (let* ((pv-offset (1+ (position name slot-names))))
  611.           (add-forms `(,@(when (plusp npop)
  612.                    `((pop-initargs ,(* 2 npop))))
  613.                (instance-set ,pv-offset ,slot))
  614.              initialize-form-list))
  615.         (incf n-popped npop)))))
  616.     (dolist (slot+index slots)
  617.       (let* ((slot (car slot+index))
  618.          (name (slot-definition-name slot)))
  619.     (when (and (eql (cdr slot+index) most-positive-fixnum)
  620.            (or (eq si-slot-names 't)
  621.                (member name si-slot-names)))
  622.       (let* ((initform (slot-definition-initform slot))
  623.          (initfunction (slot-definition-initfunction slot))
  624.          (location (unless (eq type 'structure)
  625.                  (slot-definition-location slot)))
  626.          (pv-offset (1+ (position name slot-names)))
  627.          (forms (cond ((null initfunction)
  628.                    nil)
  629.                   ((constantp initform)
  630.                    (let ((value (funcall initfunction)))
  631.                  (if (and simple-p (integerp location))
  632.                      (progn (setf (nth location constants) value)
  633.                         nil)
  634.                      `((const ,value)
  635.                        (instance-set ,pv-offset ,slot)))))
  636.                   (t
  637.                    `((funcall ,(slot-definition-initfunction slot))
  638.                  (instance-set ,pv-offset ,slot))))))
  639.         (add-forms `(,@(unless (or simple-p (null forms))
  640.                  `((skip-when-instance-boundp ,pv-offset ,slot
  641.                 ,(length forms))))
  642.              ,@forms)
  643.                initialize-form-list)))))
  644.     (values (car initialize-form-list) constants)))
  645.  
  646. (defvar *class-pv-table-table* (make-hash-table :test 'eq))
  647.  
  648. (defun get-pv-cell-for-class (class)
  649.   (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
  650.      (slot-name-lists (list (cons nil slot-names)))
  651.      (pv-table (gethash class *class-pv-table-table*)))
  652.     (unless (and pv-table
  653.          (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
  654.       (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
  655.       (setf (gethash class *class-pv-table-table*) pv-table))
  656.     (pv-table-lookup pv-table (class-wrapper class))))    
  657.  
  658. (defvar *initialize-instance-simple-alist* nil)
  659. (defvar *note-iis-entry-p* nil)
  660.  
  661. (defvar *compiled-initialize-instance-simple-functions*
  662.   (make-hash-table :test #'equal))
  663.  
  664. (defun initialize-instance-simple-function (use info class form-list)
  665.   (let* ((pv-cell (get-pv-cell-for-class class))
  666.      (key (initialize-info-key info))
  667.      (sf-key (list* use (class-name (car key)) (cdr key))))
  668.     (if (or *compile-make-instance-functions-p*
  669.         (gethash sf-key *compiled-initialize-instance-simple-functions*))
  670.     (multiple-value-bind (form args)
  671.         (form-list-to-lisp pv-cell form-list)
  672.       (let ((entry (assoc form *initialize-instance-simple-alist*
  673.                   :test #'equal)))
  674.         (setf (gethash sf-key
  675.                *compiled-initialize-instance-simple-functions*)
  676.           t)
  677.         (if entry
  678.         (setf (cdddr entry) (union (list sf-key) (cdddr entry)
  679.                        :test #'equal))
  680.         (progn
  681.           (setq entry (list* form nil nil (list sf-key)))
  682.           (setq *initialize-instance-simple-alist*
  683.             (nconc *initialize-instance-simple-alist*
  684.                    (list entry)))))
  685.         (unless (or *note-iis-entry-p* (cadr entry))
  686.           (setf (cadr entry) (compile-lambda (car entry))))
  687.         (if (cadr entry)
  688.         (apply (the function (cadr entry)) args)
  689.         `(call-initialize-instance-simple ,pv-cell ,form-list))))
  690.     #||
  691.     #'(lambda (instance initargs)
  692.         (initialize-instance-simple pv-cell form-list instance initargs))
  693.     ||#
  694.     `(call-initialize-instance-simple ,pv-cell ,form-list))))
  695.  
  696. (defun load-precompiled-iis-entry (form function system uses)
  697.   (let ((entry (assoc form *initialize-instance-simple-alist*
  698.               :test #'equal)))
  699.     (unless entry
  700.       (setq entry (list* form nil nil nil))
  701.       (setq *initialize-instance-simple-alist*
  702.         (nconc *initialize-instance-simple-alist*
  703.            (list entry))))
  704.     (setf (cadr entry) function)
  705.     (setf (caddr entry) system)
  706.     (dolist (use uses)
  707.       (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
  708.     (setf (cdddr entry) (union uses (cdddr entry)
  709.                    :test #'equal))))
  710.  
  711. (defmacro precompile-iis-functions (&optional system)
  712.   (let ((index -1))
  713.     `(progn
  714.       ,@(gathering1 (collecting)
  715.      (dolist (iis-entry *initialize-instance-simple-alist*)
  716.        (when (or (null (caddr iis-entry))
  717.              (eq (caddr iis-entry) system))
  718.          (when system (setf (caddr iis-entry) system))
  719.          (gather1
  720.           (make-top-level-form
  721.            `(precompile-initialize-instance-simple ,system ,(incf index))
  722.            '(load)
  723.            `(load-precompiled-iis-entry
  724.          ',(car iis-entry)
  725.          #',(car iis-entry)
  726.          ',system
  727.          ',(cdddr iis-entry))))))))))
  728.  
  729. (defun compile-iis-functions (after-p)
  730.   (let ((*compile-make-instance-functions-p* t)
  731.     (*revert-initialize-info-p* t)
  732.     (*note-iis-entry-p* (not after-p)))
  733.     (declare (special *compile-make-instance-functions-p*))
  734.     (when (eq *boot-state* 'complete)
  735.       (update-make-instance-function-table))))
  736.  
  737.  
  738. ;(const const)
  739. ;(funcall function)
  740. ;(push-initarg const)
  741. ;(pop-supplied count) ; a positive odd number 
  742. ;(instance-set pv-offset slotd)
  743. ;(skip-when-instance-boundp pv-offset slotd n)
  744.  
  745. (defun initialize-instance-simple (pv-cell form-list instance initargs)
  746.   (let ((pv (car pv-cell))
  747.     (initargs-tail initargs)
  748.     (slots (get-slots-or-nil instance))
  749.     (class (class-of instance))
  750.     value)
  751.     (loop (when (null form-list) (return nil))
  752.       (let ((form (pop form-list)))
  753.         (ecase (car form)
  754.           (push-initarg 
  755.            (push value initargs)
  756.            (push (cadr form) initargs))
  757.           (const
  758.            (setq value (cadr form)))
  759.           (funcall
  760.            (setq value (funcall (the function (cadr form)))))
  761.           (pop-initargs
  762.            (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
  763.            (setq value (pop initargs-tail)))
  764.           (instance-set
  765.            (instance-write-internal 
  766.         pv slots (cadr form) value
  767.         (setf (slot-value-using-class class instance (caddr form)) value)))
  768.           (skip-when-instance-boundp
  769.            (when (instance-boundp-internal 
  770.               pv slots (cadr form)
  771.               (slot-boundp-using-class class instance (caddr form)))
  772.          (dotimes (i (cadddr form))
  773.            (pop form-list))))
  774.           (update-initialize-info-cache
  775.            (when (consp initargs)
  776.          (setq initargs (cons (car initargs) (cdr initargs))))
  777.            (setq *initialize-info-cache-class* (cadr form))
  778.            (setq *initialize-info-cache-initargs* initargs)
  779.            (setq *initialize-info-cache-info* (caddr form)))
  780.           (finish-pushing-initargs
  781.            (setq initargs-tail initargs)))))
  782.     initargs))
  783.  
  784. (defun add-to-cvector (cvector constant)
  785.   (or (position constant cvector)
  786.       (prog1 (fill-pointer cvector)
  787.     (vector-push-extend constant cvector))))
  788.  
  789. (defvar *inline-iis-instance-locations-p* t)
  790.  
  791. (defun first-form-to-lisp (forms cvector pv)
  792.   (flet ((const (constant)
  793.        (cond ((or (numberp constant) (characterp constant))
  794.           constant)
  795.          ((and (symbolp constant) (symbol-package constant))
  796.           `',constant)
  797.          (t
  798.           `(svref cvector ,(add-to-cvector cvector constant))))))
  799.     (let ((form (pop (car forms))))
  800.       (ecase (car form)
  801.     (push-initarg
  802.      `((push value initargs)
  803.        (push ,(const (cadr form)) initargs)))
  804.     (const
  805.      `((setq value ,(const (cadr form)))))
  806.     (funcall
  807.      `((setq value (funcall (the function ,(const (cadr form)))))))
  808.     (pop-initargs
  809.      `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
  810.                     (case pop
  811.                       (1 `(cdr))
  812.                       (3 `(cdddr))
  813.                       (t `(nthcdr ,pop))))
  814.                 initargs-tail))
  815.        (setq value (pop initargs-tail))))
  816.     (instance-set
  817.      (let* ((pv-offset (cadr form))
  818.         (location (pvref pv pv-offset))
  819.         (default `(setf (slot-value-using-class class instance
  820.                             ,(const (caddr form)))
  821.                 value)))
  822.        (if *inline-iis-instance-locations-p*
  823.            (typecase location
  824.          (fixnum `((setf (%instance-ref slots ,(const location)) value)))
  825.          (cons `((setf (cdr ,(const location)) value)))
  826.          (t `(,default)))
  827.            `((instance-write-internal pv slots ,(const pv-offset) value
  828.           ,default
  829.           ,(typecase location
  830.              (fixnum ':instance)
  831.              (cons ':class)
  832.              (t ':default)))))))
  833.     (skip-when-instance-boundp
  834.      (let* ((pv-offset (cadr form))
  835.         (location (pvref pv pv-offset))
  836.         (default `(slot-boundp-using-class class instance
  837.                ,(const (caddr form)))))
  838.        `((unless ,(if *inline-iis-instance-locations-p*
  839.               (typecase location
  840.                 (fixnum `(not (eq (%instance-ref slots ,(const location))
  841.                           ',*slot-unbound*)))
  842.                 (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
  843.                 (t default))
  844.               `(instance-boundp-internal pv slots ,(const pv-offset)
  845.                 ,default
  846.                 ,(typecase (pvref pv pv-offset)
  847.                    (fixnum ':instance)
  848.                    (cons ':class)
  849.                    (t ':default))))
  850.            ,@(let ((sforms (cons nil nil)))
  851.            (dotimes (i (cadddr form) (car sforms))
  852.              (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
  853.     (update-initialize-info-cache
  854.      `((when (consp initargs)
  855.          (setq initargs (cons (car initargs) (cdr initargs))))
  856.        (setq *initialize-info-cache-class* ,(const (cadr form)))
  857.        (setq *initialize-info-cache-initargs* initargs)
  858.        (setq *initialize-info-cache-info* ,(const (caddr form)))))
  859.     (finish-pushing-initargs
  860.      `((setq initargs-tail initargs)))))))
  861.  
  862. (defmacro iis-body (&body forms)
  863.   `(let ((initargs-tail initargs)
  864.      (slots (get-slots-or-nil instance))
  865.      (class (class-of instance))
  866.      (pv (car pv-cell))
  867.      value)
  868.      initargs instance initargs-tail pv cvector slots class value
  869.      ,@forms))
  870.  
  871. (defun form-list-to-lisp (pv-cell form-list)
  872.   (let* ((forms (list form-list))
  873.      (cvector (make-array (floor (length form-list) 2)
  874.                   :fill-pointer 0 :adjustable t))
  875.      (pv (car pv-cell))
  876.      (body (let ((rforms (cons nil nil)))
  877.          (loop (when (null (car forms)) (return (car rforms)))
  878.                (add-forms (first-form-to-lisp forms cvector pv)
  879.                   rforms))))
  880.      (cvector-type `(simple-vector ,(length cvector))))
  881.     (values
  882.      `(lambda (pv-cell cvector)
  883.         (declare (type ,cvector-type cvector))
  884.         #'(lambda (instance initargs)
  885.         (declare #.*optimize-speed*)
  886.         (iis-body ,@body)
  887.         initargs))
  888.      (list pv-cell (coerce cvector cvector-type)))))
  889.